Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/dbcvt/dbcvt.pas

Pascal/Delphi Source File | 1995-12-22 | 13.7 KB | 505 lines

unit DBcvt;
(*
    Unit to import an ascii delmited file in to a (paradox) table
    1)    This file was formated with tabs set to 2.
    2)    On a 486/33 this parses about 200 linse per second (with 10 fields per line.)
            It's not fast but it works.

    Author: William R. Florac
  Company: FITCO, Verona, WI (wee little company from my house)
    Copyright 1995, FITCO.  All rights reserved.

 1)  Users of DBCVT (and it's components) must accept this disclaimer of
     warranty: "DBCVT is supplied as is.  The author disclaims all
     warranties, expressed or implied, including, without limitation,
     the warranties of merchantability and of fitness for any purpose.
     The author assumes no liability for damages, direct or conse-
     quential, which may result from the use of DBCVT."

    2) This component is donated to the public as public domain.

    3) This component can be freely used and distributed in commercial and private
     environments provided this notice is not modified in any way.

  4) If you do find this component handy and you feel guilty
    for using such a great product without paying someone,
    please feel free to send a few bucks ($25) to support further
    development.

 5) This file was formated with tabs set to 2.

    Please forward any comments or suggestions to Bill Florac at:
         email: [e-mail]
        mail: FITCO
                    209 Jenna Dr
                    Verona, WI  53593

    Revision History
    1.0     9-15-95    Initial release.
*)

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DBtables, DB, StdCtrls;

type
  TAscii2DB = class(TComponent)
  private
    { Private declarations }
        Fdelimiter: char;
        Fseparator: char;
        EscBS: boolean;
    FDestination: TTable;
    FAsciiFile: TFileName;
        FTickCount: word;
        FFieldList: tstrings;
        FOnTick: TNotifyEvent;
        Fcount: longInt;
        ProgressForm: TForm;
        ProgressCancel: TButton;
        Busy: boolean;
    FShowDlg: boolean;
        procedure SetFieldList(value: TStrings);
        procedure SetCount(value: LongInt);
        procedure AbortTransfer(Sender: TObject);
  protected
    { Protected declarations }
        function Parseline(line: string; var list: tstringlist): boolean;
        procedure DoUpdate;
  public
    { Public declarations }
        ErrorCode: integer;
        ParsedCount: longInt;
        constructor Create(Aowner: Tcomponent); override;
        destructor Destroy; override;
        procedure Execute;
        function GetErrorString(Ecode: integer): string;
        function GetRecordCount:LongInt;
        procedure StopExecute;
  published
    { Published declarations }
        property Delimiter: char read Fdelimiter write Fdelimiter default '"';
        property Separator: char read Fseparator write Fseparator default ',';
        property RemoveESC: boolean read EscBS write EscBS default true;
    property Destination: TTable read FDestination write FDestination;
    property AsciiFile: TFileName read FAsciiFile write FAsciiFile;
        property TickCount: word read FTickCount write FTickCount default 100;
        property RecordLimit: LongInt read FCount write SetCount default 0;
        property FieldList: TStrings read FFieldList write SetFieldList;
        property OnTick: TnotifyEvent read FOnTick write FOnTick;
        property ShowDlg: boolean read FshowDlg write FShowDlg default false;
  end;

procedure Register;

implementation

constructor TAscii2DB.Create(Aowner: Tcomponent);
begin
    inherited create(Aowner);
    Busy := false;
    Fdelimiter := '"';
    Fseparator := ',';
  FShowDlg := False;
    EscBS := true;
    FTickCount := 100;
    FCount := 0;
    FFieldList := Tstringlist.create;
    ProgressForm := TForm.Create(AOwner);
  FShowDlg := False;

    with ProgressForm do begin
        Parent := Parent;
        ClientWidth := 200;
        ClientHeight:= 40;
        BorderStyle := bsSingle;
        BorderIcons := [];
        Caption := 'Transfer Progress';
        FormStyle := fsStayOnTop;
        end;
    ProgressCancel := Tbutton.Create(AOwner);
    with ProgressCancel do begin
        Parent := ProgressForm;
        left := 0;
        width := ProgressForm.ClientWidth;
        top := ProgressForm.ClientHeight div 2 ;
        height := top;
        caption :='&Cancel';
        OnClick := AbortTransfer;
        end;
    end; {of create}

destructor TAscii2DB.Destroy;
begin
    FFieldList.Free;
    inherited destroy;
    end; {of destroy}

procedure Tascii2DB.Execute;
const
    RecordCount: LongInt = 0;

var
    ParsedList: tstringlist;
    InFile: TextFile;
    Line: String;
    DBIndex: integer;
    AsciiIndex: integer;
    FieldIndex: array[0..50] of integer;
    x: integer;
  NewRect: TRect;
    Percent: Integer;
    EndOfIt: LongInt;
    PText: String;

begin
    if busy then begin
        ErrorCode := 97;
        exit;
        end;
    Busy := true;
    {assume good}
    ErrorCode := 0;
    ParsedCount := 0;
    {make sure table is working}
    if FDestination <> nil then begin
        {table must be inactive}
        if FDestination.Active then FDestination.Close;
        {can I get exclusive rights to table?}
        try
            FDestination.Exclusive := True;
        except
            on EDatabaseError do begin
                errorCode := 1;
                busy := false;
                exit;
                end;
          end;

        {does source file exist?}
        if not FileExists(AsciiFile) then begin
            errorCode := 2;
            busy := false;
            exit;
            end;

        if FShowDlg then RecordCount := GetRecordCount;
        {open database}
        try
            FDestination.Open;
        except
            on EDatabaseError do begin
                errorCode := 3;
                busy := false;
                exit;
                end;
         end;

        {does fieldlist count match database?}
        if FDestination.FieldCount <> FFieldList.count then begin
            errorCode := 6;
            FDestination.Close; {close the database}
            busy := false;
            exit;
            end;

        {can we find all the field names, save index to them}
        for DBIndex := 0 to FFieldList.Count - 1 do begin
            if UpperCase(FFieldList[DBIndex]) <> 'SKIP' then begin
                FieldIndex[DBIndex] := Fdestination.FieldDefs.IndexOf(FFieldList[DBIndex]);
                if FieldIndex[DBIndex] < 0 then begin    {exit if we did not find it}
                    errorCode := 8;
                    FDestination.Close; {close the database}
                    busy := false;
                    exit;
                    end;
                end
        else begin
          FieldIndex[DBIndex] := 0;
                end;
            end;
        FDestination.EmptyTable;                 {empty old data}

        AssignFile(InFile, AsciiFile);  {open ascii file}
        Reset(InFile);
        ParsedList := TStringList.create; {create the string list}

        if FShowDlg then begin
            ProgressForm.Left := TForm(Owner).Left + (TForm(Owner).Width div 2) - ProgressForm.Width div 2;
            ProgressForm.Top := TForm(Owner).Top + (TForm(Owner).Height div 2) - ProgressForm.Height div 2;
            ProgressForm.Show;
            end;

        while (not eof(InFile)) and (errorCode = 0)do begin
          readln(InFile,Line);
            if not ParseLine(Line, ParsedList) then begin
                errorCode := 4;
                break;
                end
            else begin
                if ParsedList.count <> FFieldList.Count then begin
                    errorCode := 5;
                    break;
                    end;
                {This is part that is slow!}
                FDestination.Edit;
                FDestination.Insert;
                for DBIndex := 0 to FFieldList.Count - 1 do begin
                    if UpperCase(FFieldList[DBIndex]) <> 'SKIP' then begin
                        try
                           FDestination.Fields[FieldIndex[DBindex]].AsString := ParsedList[DBIndex];
               except
                            on EDataBaseError do begin
                                errorCode := 7;
                                break;
                                end;
                end;
                        end;
               end;
                {call user update and give some time to other apps}
            inc(ParsedCount);
                if FTickCount > 0 then begin
                    if ParsedCount mod FTickCount = 0 then begin
                        if FShowDlg then begin
                      if FCount > RecordCount
                            then EndOfIt := RecordCount
                            else begin
                                if Fcount =0
                then EndOfIt := RecordCount
                                else EndOfIt := Fcount;
                                end;

                            if EndOfIt <> 0
                            then Percent := ProgressForm.ClientWidth * ParsedCount div EndOfIt
                            else Percent := 0;

                            {draw left background}
                          NewRect := Rect(0, 0, Percent, ProgressForm.ClientHeight div 2);
                          ProgressForm.Canvas.Brush.Style := bsSolid;
                          ProgressForm.Canvas.Brush.Color := clRed;
                          ProgressForm.Canvas.FillRect(NewRect);

                            {draw right background}
                          NewRect := Rect(Percent, 0, ProgressForm.ClientWidth,
                                                  ProgressForm.ClientHeight div 2);
                          ProgressForm.Canvas.Brush.Color := clBtnFace;
                          ProgressForm.Canvas.FillRect(NewRect);

                            {draw text}
                            if EndOfIt <> 0
                            then Ptext := IntToStr(100 * ParsedCount div EndOfIt) + '%'
                            else Ptext := '0%';
                          ProgressForm.Canvas.Brush.Style := bsClear;
                ProgressForm.Canvas.TextOut(90,2,Ptext);
                            end;
                        DoUpdate; {call user function}
                        end;
              end;
                {are we done?}
                if (Fcount > 0) and (ParsedCount >= Fcount) then break;
                end;
          end;
        {ok, shut it all down}
        FDestination.Post;
        ProgressForm.Close;
    ParsedList.Free;             {get rid of my list}
        CloseFile(InFile);         {close source file}
        FDestination.Close;     {close the database}
        busy := false;
        end
    else begin {no destination}
        errorCode := 99;
        busy := false;
        end;
    end; {of execute}

procedure Tascii2DB.AbortTransfer(Sender: TObject);
begin
    ErrorCode := 98;
    end; {of aborttranfer}

function Tascii2DB.GetErrorString(Ecode: integer): string;
begin
    case eCode of
        0: result := 'No errors detected.';
        1: result := 'Can not get exclusive access to database.';
         2: result := 'Ascii file does not exist. [' + AsciiFile + ']';
        3: result := 'Can not open database.';
        4: result := 'Error in ascii file';
        5: result := 'Ascii table does not match database.';
        6: result := 'Field count does not match database.';
        7: result := 'Data type mismatch in ascii file.';
        8: result := 'Field names do not match database.';

        97: result := 'Busy.';
        98: result := 'User aborted.';
        99: result := 'Desitination table does not exist.';
      else result := 'Unknown error.';
        end;
    end; {of get errorstring}

function Tascii2DB.GetRecordCount: LongInt;
var
    InFile: TextFile;
    Line: String;
    counter: Longint;
begin
    if not FileExists(AsciiFile) then begin
        Result := -1;
        exit;
        end;
    AssignFile(InFile, AsciiFile);  {open ascii file}
    Reset(InFile);
    counter := 0;
    while not EOF(InFile) do begin
        readln(InFile,Line);
        inc(counter);
        end;
    CloseFile(InFile);         {close source file}
    Result := counter;
    end; {of getrecordcount}

procedure Tascii2DB.StopExecute;
begin
    {setting error code aborts}
    ErrorCode := 98;
    end;


procedure Tascii2DB.SetFieldList(Value: TStrings);
begin
  FFieldList.Assign(Value);
    end; {of setfieldlist}

procedure Tascii2DB.SetCount(value: LongInt);
begin
    if value < 0 then value := 0;
  FCount := value;
    end; {of setcount}


procedure Tascii2DB.DoUpdate;
begin
    Application.ProcessMessages;
    if assigned(FOnTick) then FOnTick(Self);
    end; {of doupdate}


function Tascii2DB.parseline(line: string; var list: tstringlist): boolean;
var
    x,SepCount: integer;
    inquote: boolean;
    subline: string;
  maxcount: integer;
    oops: boolean;
begin
{  *** parse line ***
    - look for separator marker or ENDOFLINE
      separator can not be inbetween DELIMITERS
         (if it is, it is part of the string)
    - pull out segment and delete from string
  - for each segment,
          see if first character = " if so, nuke it
          see if last character = " if so, nuke it
             look for \" if found convert it to " (if enabled)
             add to stringlist
}

    result := true;
    {clear the list}
    List.clear;
    {abort if 0 lenght string}
  if Length(line) < 1 then begin
        result := false;
        exit;
        end;

    {remove escaped "}
    if EscBS then
        while pos('\"', line) > 0 do delete(line,pos('\"', line),1);

    {flag to indicate if we are in a string record}
    inquote := false;
    {count to next separator}
    SepCount := 0;
  {no quote mistakes}
    oops := false;
    {number of characters to examine}
    maxcount := Length(Line);
    for x:= 1 to maxcount do begin
        inc(SepCount);
        {keep status to as to if we are inside delimiter}
        if line[SepCount] = Fdelimiter then begin
            {toggle status}
            {make sure its at end of record or next to a separator}
            if inquote then begin
                if SepCount <= maxcount-1 then begin
                    if Line[SepCount+1] = Fseparator
                    then inquote := false;
                    end
        else inquote := false; {EOR}
                end
            else
                {if it is not just after a separator then it was really the end of}
                {the last string (i.e. string contained "<text>",<text>"}
                if SepCount > 1 then begin
                    if Line[SepCount-1] <> Fseparator then begin
                        inquote := false;
                        oops := true;
            end;
          end
                else inquote := true;
            end;
        {ignore between delimiters}
        if not inquote then begin
            if line[SepCount] = Fseparator then begin {EOR reached}
                {get it}
                subline := copy(line, 1, SepCount-1);
                {delete it from original}
                delete(line,1,SepCount);
                {remove pre and post delimiters}
                if length(subline) > 0 then
                    if subline[1] = Fdelimiter then
                        delete(subline,1,1);
                if subline[length(subline)] = Fdelimiter then
                    dec(subline[0]);
                {add it to the list}
                if oops then begin
                    if list.Count >= 1 then
                        list[list.Count-1] := list[list.Count-1] + '",' + subline;
                    oops := false;
                    end
                else
                    list.add(subline);
                SepCount := 0;
                end;
        end;
        end;

    {clean up any remaining data}
    if length(line) > 0 then begin
        subline := line;
        {remove pre and post delimiters}
        if subline[1] = Fdelimiter then
            delete(subline,1,1);
        if subline[length(subline)] = Fdelimiter then
            dec(subline[0]);
            {add it to the list}
        if oops then begin
            list[list.Count-1] := list[list.Count-1] + '",' + subline + '<>';
            oops := false;
            end
        else
            list.add(subline);
    end;
end; {of parseline}

procedure Register;
begin
  RegisterComponents('Fitco', [Tascii2DB]);
end; {of register}

end. {of unit}